Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/buttons/toolb160/mkbitmap/move.frm

Text File | 1994-06-21 | 16KB | 533 lines

VERSION 2.00
Begin Form frmMove
   BackColor       =   &H00C0C0C0&
   Caption         =   "Bitmap creator for the TOOLBARS.VBX"
   ClientHeight    =   4215
   ClientLeft      =   1050
   ClientTop       =   1770
   ClientWidth     =   7560
   Height          =   4905
   Icon            =   MOVE.FRX:0000
   Left            =   990
   LinkTopic       =   "Form1"
   ScaleHeight     =   281
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   504
   Top             =   1140
   Width           =   7680
   Begin PictureBox picTemp
      BorderStyle     =   0  'None
      Height          =   420
      Left            =   45
      ScaleHeight     =   28
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   31
      TabIndex        =   4
      Top             =   4095
      Visible         =   0   'False
      Width           =   465
   End
   Begin PictureBox picBitmap
      BorderStyle     =   0  'None
      Height          =   420
      Left            =   540
      ScaleHeight     =   28
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   31
      TabIndex        =   5
      Top             =   4095
      Visible         =   0   'False
      Width           =   465
   End
   Begin CommonDialog CMDialog1
      Left            =   0
      Top             =   0
   End
   Begin VScrollBar vsbScroll
      Height          =   3735
      Left            =   7200
      TabIndex        =   3
      Top             =   60
      Width           =   255
   End
   Begin HScrollBar hsbScroll
      Height          =   255
      Left            =   120
      TabIndex        =   2
      Top             =   3780
      Width           =   7095
   End
   Begin PictureBox picContainer
      Height          =   3735
      Left            =   120
      ScaleHeight     =   247
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   471
      TabIndex        =   0
      Top             =   60
      Width           =   7095
      Begin PictureBox picBackGround
         BorderStyle     =   0  'None
         Height          =   11520
         Left            =   0
         ScaleHeight     =   768
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   1024
         TabIndex        =   1
         Top             =   0
         Width           =   15360
         Begin Image imgButton
            Height          =   330
            Index           =   0
            Left            =   240
            Top             =   360
            Visible         =   0   'False
            Width           =   360
         End
      End
   End
   Begin Menu mnuFile
      Caption         =   "&File"
      Begin Menu mnuNew
         Caption         =   "&New"
      End
      Begin Menu mnuOpen
         Caption         =   "&Open..."
      End
      Begin Menu mnuSave
         Caption         =   "&Save..."
      End
      Begin Menu mnuSaveAs
         Caption         =   "Save &As..."
      End
      Begin Menu mnuSep1
         Caption         =   "-"
      End
      Begin Menu mnuExit
         Caption         =   "&Exit"
      End
   End
   Begin Menu mnuOptions
      Caption         =   "&Options"
      Begin Menu mnuAutoGrid
         Caption         =   "&Auto Grid"
         Checked         =   -1  'True
      End
      Begin Menu mnuSep3
         Caption         =   "-"
      End
      Begin Menu mnuSelDir
         Caption         =   "&Select bitmapdirectory..."
      End
      Begin Menu mnuAddBitmap
         Caption         =   "&Add bitmap"
      End
      Begin Menu mnuSep2
         Caption         =   "-"
      End
      Begin Menu mnuGenerate
         Caption         =   "&Generate bitmap..."
      End
   End
End
Option Explicit
Declare Function BitBlt Lib "GDI" (ByVal hDestDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal dwRop As Long) As Integer
Const SRCCOPY = &HCC0020 ' (DWORD) dest = source

Dim miCurrentButton As Integer
Dim miOffSetX As Integer
Dim miOffSetY As Integer
Dim iNrButtons As Integer
Dim mbChanged As Integer
Dim msFileName As String
Dim miOldX As Integer, miOldY As Integer
Dim mbCancel As Integer

Const msCaption = "Bitmap creator for the TOOLBARS.VBX - "
Const msUntitled = "[Untitled]"

Sub Form_Load ()
    mbCancel = False
    mbChanged = False
    msFileName = ""
    Me.Caption = msCaption + msUntitled
    miCurrentButton = -1
    Show
    gsBitmapDir = ""
    frmSelDir.Show 1
    If gsBitmapDir <> "" Then
    Load frmSelBitmap
    frmSelBitmap.lblAction.Caption = "GO"
    End If
End Sub

Sub Form_Resize ()
    If Me.ScaleWidth - 35 > 0 Then
    picContainer.Width = Me.ScaleWidth - 35
    Else
    Exit Sub
    End If
    If Me.ScaleHeight - 35 > 0 Then
    picContainer.Height = Me.ScaleHeight - 35
    Else
    Exit Sub
    End If
    vsbScroll.Left = picContainer.Left + picContainer.Width - 1
    vsbScroll.Height = picContainer.Height
    hsbScroll.Top = picContainer.Top + picContainer.Height - 1
    hsbScroll.Width = picContainer.Width
    hsbScroll.Max = picBackGround.Width - picContainer.Height
    hsbScroll.LargeChange = 20
    hsbScroll.SmallChange = 1
    vsbScroll.Max = picBackGround.Height - picContainer.Height
    vsbScroll.LargeChange = 20
    vsbScroll.SmallChange = 1
End Sub

Sub Form_Unload (Cancel As Integer)
    If mbChanged Then
    If MsgBox("Current bitmap has changed. Save changes?", 36, "bitmap changed") = 6 Then
        mnuSave_Click
        If mbCancel Then
        Cancel = True
        Exit Sub
        End If
    End If
    End If
    Unload frmSelBitmap
    End
End Sub

Sub hsbScroll_Change ()
    ScrollHorizontal
End Sub

Sub hsbScroll_Scroll ()
    ScrollHorizontal
End Sub

Sub imgButton_DblClick (Index As Integer)
    If MsgBox("Remove this bitmap?", 36, "Remove bitmap") = 6 Then
    Unload imgButton(Index)
    End If
End Sub

Sub imgButton_MouseDown (Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    miOldX = imgButton(Index).Left
    miOldY = imgButton(Index).Top
    miCurrentButton = Index
    miOffSetX = X / Screen.TwipsPerPixelX
    miOffSetY = Y / Screen.TwipsPerPixelY
    imgButton(Index).ZOrder 0
End Sub

Sub imgButton_MouseMove (Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Index = miCurrentButton Then
    imgButton(Index).Move imgButton(Index).Left + X / Screen.TwipsPerPixelX - miOffSetX, imgButton(Index).Top + Y / Screen.TwipsPerPixelY - miOffSetY
    End If
End Sub

Sub imgButton_MouseUp (Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Index = miCurrentButton Then
    imgButton(Index).Move RoundTo(imgButton(Index).Width, imgButton(Index).Left), RoundTo(imgButton(Index).Height, imgButton(Index).Top)
    If miOldX <> imgButton(Index).Left Or miOldY <> imgButton(Index).Top Then mbChanged = True
    miCurrentButton = -1
    End If
End Sub

Sub mnuAddBitmap_Click ()
    picBackGround_DblClick
End Sub

Sub mnuAutoGrid_Click ()
    mnuAutoGrid.Checked = Not mnuAutoGrid.Checked
End Sub

Sub mnuExit_Click ()
    Unload Me
End Sub

Sub mnuGenerate_Click ()
Dim iRes As Integer
Dim I As Integer, J As Integer
Dim sFile As String
    Screen.MousePointer = 11
    frmAction!lblAction.Caption = "Generating bitmap...."
    frmAction.Show
    frmAction.Refresh
    On Local Error Resume Next
    picBitmap.Width = 0
    picBitmap.Height = 0
    For I = 1 To iNrButtons
    J = imgButton(I).Left
    If Err = 0 Then
        If imgButton(I).Left + imgButton(I).Width > picBitmap.Width Then picBitmap.Width = imgButton(I).Left + imgButton(I).Width
        If imgButton(I).Top + imgButton(I).Height > picBitmap.Height Then picBitmap.Height = imgButton(I).Top + imgButton(I).Height
        picTemp.Width = imgButton(I).Width
        picTemp.Height = imgButton(I).Height
        picTemp.Picture = imgButton(I).Picture
        picBitmap.AutoRedraw = -1
        picTemp.AutoRedraw = -1
        picTemp.Picture = picTemp.Image
        iRes = BitBlt(picBitmap.hDC, imgButton(I).Left, imgButton(I).Top, imgButton(I).Width, imgButton(I).Height, picTemp.hDC, 0, 0, SRCCOPY)
        picTemp.AutoRedraw = 0
        picBitmap.AutoRedraw = 0
        picBitmap.Picture = picBitmap.Image
    Else
        Err = 0
    End If
    Next I
    frmAction.Hide
    Screen.MousePointer = 0
    sFile = msFileName
    If sFile <> "" Then Mid$(sFile, Len(sFile), 1) = "P"
    CMDialog1.Flags = &H2
    CMDialog1.Filename = sFile
    CMDialog1.DialogTitle = "Save the generated bitmap"
    CMDialog1.Filter = "Bitmaps (*.bmp)|*.bmp"
    CMDialog1.FilterIndex = 0
    CMDialog1.CancelError = True
    On Local Error Resume Next
    CMDialog1.Action = 2
    If Err = 0 Then
    SavePicture picBitmap, CMDialog1.Filename
    End If
End Sub

Sub mnuNew_Click ()
    If mbChanged Then
    If MsgBox("Current bitmap has changed. Save changes?", 36, "bitmap changed") = 6 Then
        mnuSave_Click
        If mbCancel Then Exit Sub
    End If
    End If
    NewBitmap
    Me.Caption = msCaption + msUntitled
End Sub

Sub mnuOpen_Click ()
    If mbChanged Then
    If MsgBox("Current bitmap has changed. Save changes?", 36, "bitmap changed") = 6 Then
        mnuSave_Click
        If mbCancel Then Exit Sub
    End If
    End If
    CMDialog1.DialogTitle = "Open bitmap definition file"
    CMDialog1.Filename = msFileName
    CMDialog1.Filter = "Bitmap creator files (*.bmc)|*.bmc"
    CMDialog1.FilterIndex = 0
    CMDialog1.CancelError = True
    On Local Error Resume Next
    CMDialog1.Action = 1
    If Err = 0 Then
    msFileName = CMDialog1.Filename
    OpenFile msFileName
    End If
End Sub

Sub mnuSave_Click ()
    SaveFile False
End Sub

Sub mnuSaveAs_Click ()
    SaveFile True
End Sub

Sub mnuSelDir_Click ()
Dim sDir As String
    sDir = gsBitmapDir
    frmSelDir.Show 1
    If gsBitmapDir <> sDir Then
    frmSelBitmap!lblAction.Caption = "GO"
    End If
End Sub

Sub NewBitmap ()
Dim I As Integer
    On Local Error Resume Next
    For I = 1 To iNrButtons
    Unload imgButton(I)
    Next I
    iNrButtons = 0
End Sub

Function NormalizePath (ByVal sPath As String) As String
    If InStr(UCase$(sPath), UCase$(App.Path)) = 1 Then
    sPath = Mid$(sPath, Len(App.Path) + 1)
    If Left$(sPath, 1) = "\" Then sPath = Mid$(sPath, 2)
    End If
    NormalizePath = sPath
End Function

Sub OpenFile (ByVal sFile As String)
Dim sLine As String
Dim sBitmap As String
Dim iXpos As Integer, iYpos As Integer
Dim iFree As Integer
Dim iLineNo As Integer
Dim iPos As Integer
    Screen.MousePointer = 11
    NewBitmap
    On Local Error Resume Next
    iFree = FreeFile
    Open sFile For Input As #iFree
    iLineNo = 0
    iNrButtons = 0
    Do While EOF(iFree) = False
    Line Input #iFree, sLine
    iLineNo = iLineNo + 1
    sLine = Trim$(sLine)
    If InStr(sLine, ";") <> 1 And sLine <> "" Then
        If InStr(sLine, "=") = 0 Then
        MsgBox "Syntax error in line #" + Format$(iLineNo) + " of " + sFile + ".", 48, "Error in file"
        Else
        sLine = Trim$(Mid$(sLine, InStr(sLine, "=") + 1))
        If InStr(sLine, ",") = 0 Then
            MsgBox "Syntax error in line #" + Format$(iLineNo) + " of " + sFile + ".", 48, "Error in file"
        End If
        iNrButtons = iNrButtons + 1
        sBitmap = Left$(sLine, InStr(sLine, ",") - 1)
        sLine = Mid$(sLine, InStr(sLine, ",") + 1)
        Load imgButton(iNrButtons)
        Err = 0
        If InStr(sBitmap, ":") = 0 Then sBitmap = App.Path + "\" + sBitmap
        imgButton(iNrButtons).Picture = LoadPicture(sBitmap)
        imgButton(iNrButtons).Tag = sBitmap
        If Err > 0 Then
            MsgBox "Picture-file not found in line #" + Format$(iLineNo) + " of " + sFile + ".", 48, "Picture not loaded"
            Unload imgButton(iNrButtons)
            iNrButtons = iNrButtons - 1
        Else
            If InStr(sLine, ",") = 0 Then
            MsgBox "X-coordinate not specified in line #" + Format$(iLineNo) + " of " + sFile + ".", 48, "Wrong coordinate"
            Unload imgButton(iNrButtons)
            iNrButtons = iNrButtons - 1
            Else
            iXpos = Val(Left$(sLine, InStr(sLine, ",") - 1))
            sLine = Mid$(sLine, InStr(sLine, ",") + 1)
            If iXpos < 0 Then iXpos = 0
            If iXpos > 1024 Then iXpos = 1024 - imgButton(iNrButtons).Width
            imgButton(iNrButtons).Left = iXpos
            If sLine = "" Then
                MsgBox "Y-coordinate not specified in line #" + Format$(iLineNo) + " of " + sFile + ".", 48, "Wrong coordinate"
                Unload imgButton(iNrButtons)
                iNrButtons = iNrButtons - 1
            Else
                iYpos = Val(sLine)
                If iYpos < 0 Then iYpos = 0
                If iYpos > 768 Then iYpos = 768 - imgButton(iNrButtons).Height
                imgButton(iNrButtons).Top = iYpos
                imgButton(iNrButtons).Visible = True
                imgButton(iNrButtons).ZOrder 0
            End If
            End If
        End If
        End If
    End If
    Loop
    Close #iFree
    iPos = Len(sFile)
    Do While iPos > 0 And Mid$(sFile, iPos, 1) <> "\"
    iPos = iPos - 1
    Loop
    If iPos > 0 Then sFile = Mid$(sFile, iPos + 1)
    Me.Caption = msCaption + sFile
    mbChanged = False
    Screen.MousePointer = 0
End Sub

Sub picBackGround_DblClick ()
    gsFileName = ""
    frmSelBitmap.Show 1
    If gsFileName <> "" Then
    iNrButtons = iNrButtons + 1
    Load imgButton(iNrButtons)
    imgButton(iNrButtons).Picture = LoadPicture(gsBitmapDir & gsFileName)
    imgButton(iNrButtons).Left = (picContainer.Width - imgButton(iNrButtons).Width) \ 2 - picBackGround.Left
    imgButton(iNrButtons).Top = (picContainer.Height - imgButton(iNrButtons).Height) \ 2 - picBackGround.Top
    imgButton(iNrButtons).Tag = gsBitmapDir & gsFileName
    imgButton(iNrButtons).Visible = True
    mbChanged = True
    End If
End Sub

Function RoundTo (ByVal iWidth As Single, ByVal iX As Single) As Single
Dim iPos As Integer
    If mnuAutoGrid.Checked Then
    iPos = 0
    Do While iPos < iX
        iPos = iPos + iWidth
    Loop
    If iPos - iX > iWidth / 2 Then iPos = iPos - iWidth
    If iPos < 0 Then iPos = 0
    Else
    iPos = iX
    End If
    RoundTo = iPos
End Function

Sub SaveFile (bAskName As Integer)
Dim I As Integer
Dim J As Integer
Dim K As Integer
Dim iFree As Integer
Dim sFile As String
Dim iPos As Integer
    If msFileName = "" Or bAskName Then
    CMDialog1.DialogTitle = "Save bitmapdefinition file"
    CMDialog1.Flags = &H2
    CMDialog1.Filename = msFileName
    CMDialog1.Filter = "Bitmap creator files (*.bmc)|*.bmc"
    CMDialog1.FilterIndex = 0
    CMDialog1.CancelError = True
    On Local Error Resume Next
    CMDialog1.Action = 2
    If Err = 0 Then
        msFileName = CMDialog1.Filename
    Else
        mbCancel = True
        Exit Sub
    End If
    End If
    mbCancel = False
    iFree = FreeFile
    Open msFileName For Output As #iFree
    J = 0
    On Local Error Resume Next
    For I = 1 To iNrButtons
    K = imgButton(I).Left
    If Err = 0 Then
        J = J + 1
        Print #iFree, "bitmap " + Format$(J, "000") + " = " + UCase$(NormalizePath(imgButton(I).Tag)) + "," + Format$(imgButton(I).Left) + "," + Format$(imgButton(I).Top)
    Else
        Err = 0
    End If
    Next I
    Close #iFree
    sFile = msFileName
    iPos = Len(sFile)
    Do While iPos > 0 And Mid$(sFile, iPos, 1) <> "\"
    iPos = iPos - 1
    Loop
    If iPos > 0 Then sFile = Mid$(sFile, iPos + 1)
    Me.Caption = msCaption + sFile
    mbChanged = False
End Sub

Sub ScrollHorizontal ()
    picBackGround.Left = -hsbScroll.Value
End Sub

Sub ScrollVertical ()
    picBackGround.Top = -vsbScroll.Value
End Sub

Sub vsbScroll_Change ()
    ScrollVertical
End Sub

Sub vsbScroll_Scroll ()
    ScrollVertical
End Sub